home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclVar.c < prev   
Encoding:
C/C++ Source or Header  |  1993-10-25  |  65.6 KB  |  2,368 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_VAR
  3. #endif
  4.  
  5. /* 
  6.  * tclVar.c --
  7.  *
  8.  *    This file contains routines that implement Tcl variables
  9.  *    (both scalars and arrays).
  10.  *
  11.  *    The implementation of arrays is modelled after an initial
  12.  *    implementation by Mark Diekhans and Karl Lehenbauer.
  13.  *
  14.  * Copyright (c) 1987-1993 The Regents of the University of California.
  15.  * All rights reserved.
  16.  *
  17.  * Permission is hereby granted, without written agreement and without
  18.  * license or royalty fees, to use, copy, modify, and distribute this
  19.  * software and its documentation for any purpose, provided that the
  20.  * above copyright notice and the following two paragraphs appear in
  21.  * all copies of this software.
  22.  * 
  23.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  24.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  25.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  26.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27.  *
  28.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  29.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  30.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  31.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  32.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  33.  */
  34.  
  35. #ifndef lint
  36. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.44 93/08/14 17:21:34 ouster Exp $ SPRITE (Berkeley)";
  37. #endif
  38.  
  39. #include "tclInt.h"
  40.  
  41. /*
  42.  * The strings below are used to indicate what went wrong when a
  43.  * variable access is denied.
  44.  */
  45.  
  46. static char *noSuchVar =    "no such variable";
  47. static char *isArray =        "variable is array";
  48. static char *needArray =    "variable isn't array";
  49. static char *noSuchElement =    "no such element in array";
  50. static char *danglingUpvar =    "upvar refers to element in deleted array";
  51.  
  52. /*
  53.  * Creation flag values passed in to LookupVar:
  54.  *
  55.  * CRT_PART1 -        1 means create hash table entry for part 1 of
  56.  *            name, if it doesn't already exist.  0 means
  57.  *            return an error if it doesn't exist.
  58.  * CRT_PART2 -        1 means create hash table entry for part 2 of
  59.  *            name, if it doesn't already exist.  0 means
  60.  *            return an error if it doesn't exist.
  61.  */
  62.  
  63. #define CRT_PART1    1
  64. #define CRT_PART2    2
  65.  
  66. /*
  67.  * Forward references to procedures defined later in this file:
  68.  */
  69.  
  70. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  71.                 Var *varPtr, char *part1, char *part2,
  72.                 int flags));
  73. static void        CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr));
  74. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  75. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  76.                 Var *varPtr, int flags));
  77. static Var *        LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1,
  78.                 char *part2, int flags, char *msg, int create,
  79.                 Var **arrayPtrPtr));
  80. static int        MakeUpvar _ANSI_ARGS_((Interp *iPtr,
  81.                 CallFrame *framePtr, char *otherP1,
  82.                 char *otherP2, char *myName));
  83. static Var *        NewVar _ANSI_ARGS_((void));
  84. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  85.                 Var *varPtr, char *varName, char *string));
  86. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  87.                 char *part1, char *part2, char *operation,
  88.                 char *reason));
  89.  
  90. /*
  91.  *----------------------------------------------------------------------
  92.  *
  93.  * LookupVar --
  94.  *
  95.  *    This procedure is used by virtually all of the variable
  96.  *    code to locate a variable given its name(s).
  97.  *
  98.  * Results:
  99.  *    The return value is a pointer to the variable indicated by
  100.  *    part1 and part2, or NULL if the variable couldn't be found.
  101.  *    If the variable is found, *arrayPtrPtr is filled in with
  102.  *    the address of the array that contains the variable (or NULL
  103.  *    if the variable is a scalar).  Note:  it's possible that the
  104.  *    variable returned may be VAR_UNDEFINED, even if CRT_PART1 and
  105.  *    CRT_PART2 are specified (these only cause the hash table entry
  106.  *    and/or array to be created).
  107.  *
  108.  * Side effects:
  109.  *    None.
  110.  *
  111.  *----------------------------------------------------------------------
  112.  */
  113.  
  114. static Var *
  115. LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr)
  116.     Tcl_Interp *interp;        /* Interpreter to use for lookup. */
  117.     char *part1;        /* If part2 is NULL, this is name of scalar
  118.                  * variable.  Otherwise it is name of array. */
  119.     char *part2;        /* Name of an element within array, or NULL. */
  120.     int flags;            /* Only the TCL_GLOBAL_ONLY and
  121.                  * TCL_LEAVE_ERR_MSG bits matter. */
  122.     char *msg;            /* Verb to use in error messages, e.g.
  123.                  * "read" or "set".  Only needed if
  124.                  * TCL_LEAVE_ERR_MSG is set in flags. */
  125.     int create;            /* OR'ed combination of CRT_PART1 and
  126.                  * CRT_PART2.  Tells which entries to create
  127.                  * if they don't already exist. */
  128.     Var **arrayPtrPtr;        /* If part2 is non-NULL, *arrayPtrPtr gets
  129.                  * filled in with address of array variable. */
  130. {
  131.     Interp *iPtr = (Interp *) interp;
  132.     Tcl_HashTable *tablePtr;
  133.     Tcl_HashEntry *hPtr;
  134.     Var *varPtr;
  135.     int new;
  136.  
  137.     /*
  138.      * Lookup part1.
  139.      */
  140.  
  141.     *arrayPtrPtr = NULL;
  142.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  143.     tablePtr = &iPtr->globalTable;
  144.     } else {
  145.     tablePtr = &iPtr->varFramePtr->varTable;
  146.     }
  147.     if (create & CRT_PART1) {
  148.     hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new);
  149.     if (new) {
  150.         varPtr = NewVar();
  151.         Tcl_SetHashValue(hPtr, varPtr);
  152.         varPtr->hPtr = hPtr;
  153.     }
  154.     } else {
  155.     hPtr = Tcl_FindHashEntry(tablePtr, part1);
  156.     if (hPtr == NULL) {
  157.         if (flags & TCL_LEAVE_ERR_MSG) {
  158.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  159.         }
  160.         return NULL;
  161.     }
  162.     }
  163.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  164.     if (varPtr->flags & VAR_UPVAR) {
  165.     varPtr = varPtr->value.upvarPtr;
  166.     }
  167.  
  168.     if (part2 == NULL) {
  169.     return varPtr;
  170.     }
  171.  
  172.     /*
  173.      * We're dealing with an array element, so make sure the variable
  174.      * is an array and lookup the element (create it if desired).
  175.      */
  176.  
  177.     if (varPtr->flags & VAR_UNDEFINED) {
  178.     if (!(create & CRT_PART1)) {
  179.         if (flags & TCL_LEAVE_ERR_MSG) {
  180.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  181.         }
  182.         return NULL;
  183.     }
  184.     varPtr->flags = VAR_ARRAY;
  185.     varPtr->value.tablePtr = (Tcl_HashTable *)
  186.         ckalloc(sizeof(Tcl_HashTable));
  187.     Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  188.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  189.     if (flags & TCL_LEAVE_ERR_MSG) {
  190.         VarErrMsg(interp, part1, part2, msg, needArray);
  191.     }
  192.     return NULL;
  193.     }
  194.     *arrayPtrPtr = varPtr;
  195.     if (create & CRT_PART2) {
  196.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
  197.     if (new) {
  198.         if (varPtr->searchPtr != NULL) {
  199.         DeleteSearches(varPtr);
  200.         }
  201.         varPtr = NewVar();
  202.         Tcl_SetHashValue(hPtr, varPtr);
  203.         varPtr->hPtr = hPtr;
  204.     }
  205.     } else {
  206.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  207.     if (hPtr == NULL) {
  208.         if (flags & TCL_LEAVE_ERR_MSG) {
  209.         VarErrMsg(interp, part1, part2, msg, noSuchElement);
  210.         }
  211.         return NULL;
  212.     }
  213.     }
  214.     return (Var *) Tcl_GetHashValue(hPtr);
  215. }
  216.  
  217. /*
  218.  *----------------------------------------------------------------------
  219.  *
  220.  * Tcl_GetVar --
  221.  *
  222.  *    Return the value of a Tcl variable.
  223.  *
  224.  * Results:
  225.  *    The return value points to the current value of varName.  If
  226.  *    the variable is not defined or can't be read because of a clash
  227.  *    in array usage then a NULL pointer is returned and an error
  228.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  229.  *    flag is set.  Note:  the return value is only valid up until
  230.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  231.  *    the value lasting longer than that, then make yourself a private
  232.  *    copy.
  233.  *
  234.  * Side effects:
  235.  *    None.
  236.  *
  237.  *----------------------------------------------------------------------
  238.  */
  239.  
  240. char *
  241. Tcl_GetVar(interp, varName, flags)
  242.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  243.                  * to be looked up. */
  244.     char *varName;        /* Name of a variable in interp. */
  245.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  246.                  * or TCL_LEAVE_ERR_MSG bits. */
  247. {
  248.     register char *p;
  249.  
  250.     /*
  251.      * If varName refers to an array (it ends with a parenthesized
  252.      * element name), then handle it specially.
  253.      */
  254.  
  255.     for (p = varName; *p != '\0'; p++) {
  256.     if (*p == '(') {
  257.         char *result;
  258.         char *open = p;
  259.  
  260.         do {
  261.         p++;
  262.         } while (*p != '\0');
  263.         p--;
  264.         if (*p != ')') {
  265.         goto scalar;
  266.         }
  267.         *open = '\0';
  268.         *p = '\0';
  269.         result = Tcl_GetVar2(interp, varName, open+1, flags);
  270.         *open = '(';
  271.         *p = ')';
  272.         return result;
  273.     }
  274.     }
  275.  
  276.     scalar:
  277.     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
  278. }
  279.  
  280. /*
  281.  *----------------------------------------------------------------------
  282.  *
  283.  * Tcl_GetVar2 --
  284.  *
  285.  *    Return the value of a Tcl variable, given a two-part name
  286.  *    consisting of array name and element within array.
  287.  *
  288.  * Results:
  289.  *    The return value points to the current value of the variable
  290.  *    given by part1 and part2.  If the specified variable doesn't
  291.  *    exist, or if there is a clash in array usage, then NULL is
  292.  *    returned and a message will be left in interp->result if the
  293.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  294.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  295.  *    if you depend on the value lasting longer than that, then make
  296.  *    yourself a private copy.
  297.  *
  298.  * Side effects:
  299.  *    None.
  300.  *
  301.  *----------------------------------------------------------------------
  302.  */
  303.  
  304. char *
  305. Tcl_GetVar2(interp, part1, part2, flags)
  306.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  307.                  * to be looked up. */
  308.     char *part1;        /* Name of array (if part2 is NULL) or
  309.                  * name of variable. */
  310.     char *part2;        /* If non-null, gives name of element in
  311.                  * array. */
  312.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  313.                  * or TCL_LEAVE_ERR_MSG bits. */
  314. {
  315.     Var *varPtr, *arrayPtr;
  316.     Interp *iPtr = (Interp *) interp;
  317.  
  318.     varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2,
  319.         &arrayPtr);
  320.     if (varPtr == NULL) {
  321.     return NULL;
  322.     }
  323.  
  324.     /*
  325.      * Invoke any traces that have been set for the variable.
  326.      */
  327.  
  328.     if ((varPtr->tracePtr != NULL)
  329.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  330.     char *msg;
  331.  
  332.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  333.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  334.     if (msg != NULL) {
  335.         VarErrMsg(interp, part1, part2, "read", msg);
  336.         goto cleanup;
  337.     }
  338.     }
  339.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  340.     return varPtr->value.string;
  341.     }
  342.     if (flags & TCL_LEAVE_ERR_MSG) {
  343.     char *msg;
  344.  
  345.     if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL)
  346.         && !(arrayPtr->flags & VAR_UNDEFINED)) {
  347.         msg = noSuchElement;
  348.     } else {
  349.         msg = noSuchVar;
  350.     }
  351.     VarErrMsg(interp, part1, part2, "read", msg);
  352.     }
  353.  
  354.     /*
  355.      * If the variable doesn't exist anymore and no-one's using it,
  356.      * then free up the relevant structures and hash table entries.
  357.      */
  358.  
  359.     cleanup:
  360.     if (varPtr->flags & VAR_UNDEFINED) {
  361.     CleanupVar(varPtr, arrayPtr);
  362.     }
  363.     return NULL;
  364. }
  365.  
  366. /*
  367.  *----------------------------------------------------------------------
  368.  *
  369.  * Tcl_SetVar --
  370.  *
  371.  *    Change the value of a variable.
  372.  *
  373.  * Results:
  374.  *    Returns a pointer to the malloc'ed string holding the new
  375.  *    value of the variable.  The caller should not modify this
  376.  *    string.  If the write operation was disallowed then NULL
  377.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  378.  *    an explanatory message will be left in interp->result.
  379.  *
  380.  * Side effects:
  381.  *    If varName is defined as a local or global variable in interp,
  382.  *    its value is changed to newValue.  If varName isn't currently
  383.  *    defined, then a new global variable by that name is created.
  384.  *
  385.  *----------------------------------------------------------------------
  386.  */
  387.  
  388. char *
  389. Tcl_SetVar(interp, varName, newValue, flags)
  390.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  391.                  * to be looked up. */
  392.     char *varName;        /* Name of a variable in interp. */
  393.     char *newValue;        /* New value for varName. */
  394.     int flags;            /* Various flags that tell how to set value:
  395.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  396.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
  397. {
  398.     register char *p;
  399.  
  400.     /*
  401.      * If varName refers to an array (it ends with a parenthesized
  402.      * element name), then handle it specially.
  403.      */
  404.  
  405.     for (p = varName; *p != '\0'; p++) {
  406.     if (*p == '(') {
  407.         char *result;
  408.         char *open = p;
  409.  
  410.         do {
  411.         p++;
  412.         } while (*p != '\0');
  413.         p--;
  414.         if (*p != ')') {
  415.         goto scalar;
  416.         }
  417.         *open = '\0';
  418.         *p = '\0';
  419.         result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
  420.         *open = '(';
  421.         *p = ')';
  422.         return result;
  423.     }
  424.     }
  425.  
  426.     scalar:
  427.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
  428. }
  429.  
  430. /*
  431.  *----------------------------------------------------------------------
  432.  *
  433.  * Tcl_SetVar2 --
  434.  *
  435.  *    Given a two-part variable name, which may refer either to a
  436.  *    scalar variable or an element of an array, change the value
  437.  *    of the variable.  If the named scalar or array or element
  438.  *    doesn't exist then create one.
  439.  *
  440.  * Results:
  441.  *    Returns a pointer to the malloc'ed string holding the new
  442.  *    value of the variable.  The caller should not modify this
  443.  *    string.  If the write operation was disallowed because an
  444.  *    array was expected but not found (or vice versa), then NULL
  445.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  446.  *    an explanatory message will be left in interp->result.
  447.  *
  448.  * Side effects:
  449.  *    The value of the given variable is set.  If either the array
  450.  *    or the entry didn't exist then a new one is created.
  451.  *
  452.  *----------------------------------------------------------------------
  453.  */
  454.  
  455. char *
  456. Tcl_SetVar2(interp, part1, part2, newValue, flags)
  457.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  458.                  * to be looked up. */
  459.     char *part1;        /* If part2 is NULL, this is name of scalar
  460.                  * variable.  Otherwise it is name of array. */
  461.     char *part2;        /* Name of an element within array, or NULL. */
  462.     char *newValue;        /* New value for variable. */
  463.     int flags;            /* Various flags that tell how to set value:
  464.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  465.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG . */
  466. {
  467.     register Var *varPtr;
  468.     register Interp *iPtr = (Interp *) interp;
  469.     int length, listFlags;
  470.     Var *arrayPtr;
  471.     char *result;
  472.  
  473.     varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2,
  474.         &arrayPtr);
  475.     if (varPtr == NULL) {
  476.     return NULL;
  477.     }
  478.  
  479.     /*
  480.      * If the variable's hPtr field is NULL, it means that this is an
  481.      * upvar to an array element where the array was deleted, leaving
  482.      * the element dangling at the end of the upvar.  Generate an error
  483.      * (allowing the variable to be reset would screw up our storage
  484.      * allocation and is meaningless anyway).
  485.      */
  486.  
  487.     if (varPtr->hPtr == NULL) {
  488.     if (flags & TCL_LEAVE_ERR_MSG) {
  489.         VarErrMsg(interp, part1, part2, "set", danglingUpvar);
  490.     }
  491.     return NULL;
  492.     }
  493.  
  494.     /*
  495.      * Clear the variable's current value unless this is an
  496.      * append operation.
  497.      */
  498.  
  499.     if (varPtr->flags & VAR_ARRAY) {
  500.     if (flags & TCL_LEAVE_ERR_MSG) {
  501.         VarErrMsg(interp, part1, part2, "set", isArray);
  502.     }
  503.     return NULL;
  504.     }
  505.     if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
  506.     varPtr->valueLength = 0;
  507.     }
  508.  
  509.     /*
  510.      * Compute how many total bytes will be needed for the variable's
  511.      * new value (leave space for a separating space between list
  512.      * elements).  Allocate new space for the value if needed.
  513.      */
  514.  
  515.     if (flags & TCL_LIST_ELEMENT) {
  516.     length = Tcl_ScanElement(newValue, &listFlags) + 1;
  517.     } else {
  518.     length = strlen(newValue);
  519.     }
  520.     length += varPtr->valueLength;
  521.     if (length >= varPtr->valueSpace) {
  522.     char *newValue;
  523.     int newSize;
  524.  
  525.     newSize = 2*varPtr->valueSpace;
  526.     if (newSize <= length) {
  527.         newSize = length + 1;
  528.     }
  529.     if (newSize < 24) {
  530.         /*
  531.          * Don't waste time with teensy-tiny variables;  we'll
  532.          * just end up expanding them later.
  533.          */
  534.  
  535.         newSize = 24;
  536.     }
  537.     newValue = ckalloc((unsigned) newSize);
  538.     if (varPtr->valueSpace > 0) {
  539.         strcpy(newValue, varPtr->value.string);
  540.         ckfree(varPtr->value.string);
  541.     }
  542.     varPtr->valueSpace = newSize;
  543.     varPtr->value.string = newValue;
  544.     }
  545.  
  546.     /*
  547.      * Append the new value to the variable, either as a list
  548.      * element or as a string.
  549.      */
  550.  
  551.     if (flags & TCL_LIST_ELEMENT) {
  552.     char *dst = varPtr->value.string + varPtr->valueLength;
  553.  
  554.     if ((varPtr->valueLength > 0) && ((dst[-1] != '{')
  555.         || ((varPtr->valueLength > 1) && (dst[-2] == '\\')))) {
  556.         *dst = ' ';
  557.         dst++;
  558.         varPtr->valueLength++;
  559.     }
  560.     varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags);
  561.     } else {
  562.     strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  563.     varPtr->valueLength = length;
  564.     }
  565.     varPtr->flags &= ~VAR_UNDEFINED;
  566.  
  567.     /*
  568.      * Invoke any write traces for the variable.
  569.      */
  570.  
  571.     if ((varPtr->tracePtr != NULL)
  572.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  573.     char *msg;
  574.  
  575.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  576.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
  577.     if (msg != NULL) {
  578.         VarErrMsg(interp, part1, part2, "set", msg);
  579.         result = NULL;
  580.         goto cleanup;
  581.     }
  582.     }
  583.  
  584.     /*
  585.      * If the variable was changed in some gross way by a trace (e.g.
  586.      * it was unset and then recreated as an array) then just return
  587.      * an empty string;  otherwise return the variable's current
  588.      * value.
  589.      */
  590.  
  591.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  592.     return varPtr->value.string;
  593.     }
  594.     result = "";
  595.  
  596.     /*
  597.      * If the variable doesn't exist anymore and no-one's using it,
  598.      * then free up the relevant structures and hash table entries.
  599.      */
  600.  
  601.     cleanup:
  602.     if (varPtr->flags & VAR_UNDEFINED) {
  603.     CleanupVar(varPtr, arrayPtr);
  604.     }
  605.     return result;
  606. }
  607.  
  608. /*
  609.  *----------------------------------------------------------------------
  610.  *
  611.  * Tcl_UnsetVar --
  612.  *
  613.  *    Delete a variable, so that it may not be accessed anymore.
  614.  *
  615.  * Results:
  616.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  617.  *    if the variable can't be unset.  In the event of an error,
  618.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  619.  *    is left in interp->result.
  620.  *
  621.  * Side effects:
  622.  *    If varName is defined as a local or global variable in interp,
  623.  *    it is deleted.
  624.  *
  625.  *----------------------------------------------------------------------
  626.  */
  627.  
  628. int
  629. Tcl_UnsetVar(interp, varName, flags)
  630.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  631.                  * to be looked up. */
  632.     char *varName;        /* Name of a variable in interp.  May be
  633.                  * either a scalar name or an array name
  634.                  * or an element in an array. */
  635.     int flags;            /* OR-ed combination of any of
  636.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  637. {
  638.     register char *p;
  639.     int result;
  640.  
  641.     /*
  642.      * Figure out whether this is an array reference, then call
  643.      * Tcl_UnsetVar2 to do all the real work.
  644.      */
  645.  
  646.     for (p = varName; *p != '\0'; p++) {
  647.     if (*p == '(') {
  648.         char *open = p;
  649.  
  650.         do {
  651.         p++;
  652.         } while (*p != '\0');
  653.         p--;
  654.         if (*p != ')') {
  655.         goto scalar;
  656.         }
  657.         *open = '\0';
  658.         *p = '\0';
  659.         result = Tcl_UnsetVar2(interp, varName, open+1, flags);
  660.         *open = '(';
  661.         *p = ')';
  662.         return result;
  663.     }
  664.     }
  665.  
  666.     scalar:
  667.     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
  668. }
  669.  
  670. /*
  671.  *----------------------------------------------------------------------
  672.  *
  673.  * Tcl_UnsetVar2 --
  674.  *
  675.  *    Delete a variable, given a 2-part name.
  676.  *
  677.  * Results:
  678.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  679.  *    if the variable can't be unset.  In the event of an error,
  680.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  681.  *    is left in interp->result.
  682.  *
  683.  * Side effects:
  684.  *    If part1 and part2 indicate a local or global variable in interp,
  685.  *    it is deleted.  If part1 is an array name and part2 is NULL, then
  686.  *    the whole array is deleted.
  687.  *
  688.  *----------------------------------------------------------------------
  689.  */
  690.  
  691. int
  692. Tcl_UnsetVar2(interp, part1, part2, flags)
  693.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  694.                  * to be looked up. */
  695.     char *part1;        /* Name of variable or array. */
  696.     char *part2;        /* Name of element within array or NULL. */
  697.     int flags;            /* OR-ed combination of any of
  698.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  699. {
  700.     Var *varPtr, dummyVar;
  701.     Interp *iPtr = (Interp *) interp;
  702.     Var *arrayPtr;
  703.     ActiveVarTrace *activePtr;
  704.     int result;
  705.  
  706.     varPtr = LookupVar(interp, part1, part2, flags, "unset", 0,  &arrayPtr);
  707.     if (varPtr == NULL) {
  708.     return TCL_ERROR;
  709.     }
  710.     result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK;
  711.  
  712.     if ((part2 != NULL) && (arrayPtr->searchPtr != NULL)) {
  713.     DeleteSearches(arrayPtr);
  714.     }
  715.  
  716.     /*
  717.      * The code below is tricky, because of the possibility that
  718.      * a trace procedure might try to access a variable being
  719.      * deleted.  To handle this situation gracefully, do things
  720.      * in three steps:
  721.      * 1. Copy the contents of the variable to a dummy variable
  722.      *    structure, and mark the original structure as undefined.
  723.      * 2. Invoke traces and clean up the variable, using the copy.
  724.      * 3. If at the end of this the original variable is still
  725.      *    undefined and has no outstanding references, then delete
  726.      *      it (but it could have gotten recreated by a trace).
  727.      */
  728.  
  729.     dummyVar = *varPtr;
  730.     varPtr->valueSpace = 0;
  731.     varPtr->flags = VAR_UNDEFINED;
  732.     varPtr->tracePtr = NULL;
  733.  
  734.     /*
  735.      * Call trace procedures for the variable being deleted and delete
  736.      * its traces.  Be sure to abort any other traces for the variable
  737.      * that are still pending.  Special tricks:
  738.      * 1. Increment varPtr's refCount around this:  CallTraces will
  739.      *    use dummyVar so it won't increment varPtr's refCount.
  740.      * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
  741.      *    call unset traces even if other traces are pending.
  742.      */
  743.  
  744.     if ((dummyVar.tracePtr != NULL)
  745.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  746.     varPtr->refCount++;
  747.     dummyVar.flags &= ~VAR_TRACE_ACTIVE;
  748.     (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
  749.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  750.     while (dummyVar.tracePtr != NULL) {
  751.         VarTrace *tracePtr = dummyVar.tracePtr;
  752.         dummyVar.tracePtr = tracePtr->nextPtr;
  753.         ckfree((char *) tracePtr);
  754.     }
  755.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  756.         activePtr = activePtr->nextPtr) {
  757.         if (activePtr->varPtr == varPtr) {
  758.         activePtr->nextTracePtr = NULL;
  759.         }
  760.     }
  761.     varPtr->refCount--;
  762.     }
  763.  
  764.     /*
  765.      * If the variable is an array, delete all of its elements.  This
  766.      * must be done after calling the traces on the array, above (that's
  767.      * the way traces are defined).
  768.      */
  769.  
  770.     if (dummyVar.flags & VAR_ARRAY) {
  771.     DeleteArray(iPtr, part1, &dummyVar,
  772.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  773.     }
  774.     if (dummyVar.valueSpace > 0) {
  775.     ckfree(dummyVar.value.string);
  776.     }
  777.     if (result == TCL_ERROR) {
  778.     if (flags & TCL_LEAVE_ERR_MSG) {
  779.         VarErrMsg(interp, part1, part2, "unset", 
  780.             (part2 == NULL) ? noSuchVar : noSuchElement);
  781.     }
  782.     }
  783.  
  784.     /*
  785.      * Finally, if the variable is truly not in use then free up its
  786.      * record and remove it from the hash table.
  787.      */
  788.  
  789.     CleanupVar(varPtr, arrayPtr);
  790.     return result;
  791. }
  792.  
  793. /*
  794.  *----------------------------------------------------------------------
  795.  *
  796.  * Tcl_TraceVar --
  797.  *
  798.  *    Arrange for reads and/or writes to a variable to cause a
  799.  *    procedure to be invoked, which can monitor the operations
  800.  *    and/or change their actions.
  801.  *
  802.  * Results:
  803.  *    A standard Tcl return value.
  804.  *
  805.  * Side effects:
  806.  *    A trace is set up on the variable given by varName, such that
  807.  *    future references to the variable will be intermediated by
  808.  *    proc.  See the manual entry for complete details on the calling
  809.  *    sequence for proc.
  810.  *
  811.  *----------------------------------------------------------------------
  812.  */
  813.  
  814. int
  815. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  816.     Tcl_Interp *interp;        /* Interpreter in which variable is
  817.                  * to be traced. */
  818.     char *varName;        /* Name of variable;  may end with "(index)"
  819.                  * to signify an array reference. */
  820.     int flags;            /* OR-ed collection of bits, including any
  821.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  822.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  823.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  824.                  * invoked upon varName. */
  825.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  826. {
  827.     register char *p;
  828.  
  829.     /*
  830.      * If varName refers to an array (it ends with a parenthesized
  831.      * element name), then handle it specially.
  832.      */
  833.  
  834.     for (p = varName; *p != '\0'; p++) {
  835.     if (*p == '(') {
  836.         int result;
  837.         char *open = p;
  838.  
  839.         do {
  840.         p++;
  841.         } while (*p != '\0');
  842.         p--;
  843.         if (*p != ')') {
  844.         goto scalar;
  845.         }
  846.         *open = '\0';
  847.         *p = '\0';
  848.         result = Tcl_TraceVar2(interp, varName, open+1, flags,
  849.             proc, clientData);
  850.         *open = '(';
  851.         *p = ')';
  852.         return result;
  853.     }
  854.     }
  855.  
  856.     scalar:
  857.     return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
  858.         proc, clientData);
  859. }
  860.  
  861. /*
  862.  *----------------------------------------------------------------------
  863.  *
  864.  * Tcl_TraceVar2 --
  865.  *
  866.  *    Arrange for reads and/or writes to a variable to cause a
  867.  *    procedure to be invoked, which can monitor the operations
  868.  *    and/or change their actions.
  869.  *
  870.  * Results:
  871.  *    A standard Tcl return value.
  872.  *
  873.  * Side effects:
  874.  *    A trace is set up on the variable given by part1 and part2, such
  875.  *    that future references to the variable will be intermediated by
  876.  *    proc.  See the manual entry for complete details on the calling
  877.  *    sequence for proc.
  878.  *
  879.  *----------------------------------------------------------------------
  880.  */
  881.  
  882. int
  883. Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
  884.     Tcl_Interp *interp;        /* Interpreter in which variable is
  885.                  * to be traced. */
  886.     char *part1;        /* Name of scalar variable or array. */
  887.     char *part2;        /* Name of element within array;  NULL means
  888.                  * trace applies to scalar variable or array
  889.                  * as-a-whole. */
  890.     int flags;            /* OR-ed collection of bits, including any
  891.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  892.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  893.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  894.                  * invoked upon varName. */
  895.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  896. {
  897.     Var *varPtr, *arrayPtr;
  898.     register VarTrace *tracePtr;
  899.  
  900.     varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG),
  901.         "trace", CRT_PART1|CRT_PART2, &arrayPtr);
  902.     if (varPtr == NULL) {
  903.     return TCL_ERROR;
  904.     }
  905.  
  906.     /*
  907.      * Set up trace information.
  908.      */
  909.  
  910.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  911.     tracePtr->traceProc = proc;
  912.     tracePtr->clientData = clientData;
  913.     tracePtr->flags = flags &
  914.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  915.     tracePtr->nextPtr = varPtr->tracePtr;
  916.     varPtr->tracePtr = tracePtr;
  917.     return TCL_OK;
  918. }
  919.  
  920. /*
  921.  *----------------------------------------------------------------------
  922.  *
  923.  * Tcl_UntraceVar --
  924.  *
  925.  *    Remove a previously-created trace for a variable.
  926.  *
  927.  * Results:
  928.  *    None.
  929.  *
  930.  * Side effects:
  931.  *    If there exists a trace for the variable given by varName
  932.  *    with the given flags, proc, and clientData, then that trace
  933.  *    is removed.
  934.  *
  935.  *----------------------------------------------------------------------
  936.  */
  937.  
  938. void
  939. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  940.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  941.     char *varName;        /* Name of variable;  may end with "(index)"
  942.                  * to signify an array reference. */
  943.     int flags;            /* OR-ed collection of bits describing
  944.                  * current trace, including any of
  945.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  946.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  947.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  948.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  949. {
  950.     register char *p;
  951.  
  952.     /*
  953.      * If varName refers to an array (it ends with a parenthesized
  954.      * element name), then handle it specially.
  955.      */
  956.  
  957.     for (p = varName; *p != '\0'; p++) {
  958.     if (*p == '(') {
  959.         char *open = p;
  960.  
  961.         do {
  962.         p++;
  963.         } while (*p != '\0');
  964.         p--;
  965.         if (*p != ')') {
  966.         goto scalar;
  967.         }
  968.         *open = '\0';
  969.         *p = '\0';
  970.         Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
  971.         *open = '(';
  972.         *p = ')';
  973.         return;
  974.     }
  975.     }
  976.  
  977.     scalar:
  978.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
  979. }
  980.  
  981. /*
  982.  *----------------------------------------------------------------------
  983.  *
  984.  * Tcl_UntraceVar2 --
  985.  *
  986.  *    Remove a previously-created trace for a variable.
  987.  *
  988.  * Results:
  989.  *    None.
  990.  *
  991.  * Side effects:
  992.  *    If there exists a trace for the variable given by part1
  993.  *    and part2 with the given flags, proc, and clientData, then
  994.  *    that trace is removed.
  995.  *
  996.  *----------------------------------------------------------------------
  997.  */
  998.  
  999. void
  1000. Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
  1001.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  1002.     char *part1;        /* Name of variable or array. */
  1003.     char *part2;        /* Name of element within array;  NULL means
  1004.                  * trace applies to scalar variable or array
  1005.                  * as-a-whole. */
  1006.     int flags;            /* OR-ed collection of bits describing
  1007.                  * current trace, including any of
  1008.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  1009.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  1010.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1011.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  1012. {
  1013.     register VarTrace *tracePtr;
  1014.     VarTrace *prevPtr;
  1015.     Var *varPtr, *arrayPtr;
  1016.     Interp *iPtr = (Interp *) interp;
  1017.     ActiveVarTrace *activePtr;
  1018.  
  1019.     varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY,
  1020.         (char *) NULL, 0, &arrayPtr);
  1021.     if (varPtr == NULL) {
  1022.     return;
  1023.     }
  1024.  
  1025.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  1026.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  1027.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  1028.     if (tracePtr == NULL) {
  1029.         return;
  1030.     }
  1031.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  1032.         && (tracePtr->clientData == clientData)) {
  1033.         break;
  1034.     }
  1035.     }
  1036.  
  1037.     /*
  1038.      * The code below makes it possible to delete traces while traces
  1039.      * are active:  it makes sure that the deleted trace won't be
  1040.      * processed by CallTraces.
  1041.      */
  1042.  
  1043.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  1044.         activePtr = activePtr->nextPtr) {
  1045.     if (activePtr->nextTracePtr == tracePtr) {
  1046.         activePtr->nextTracePtr = tracePtr->nextPtr;
  1047.     }
  1048.     }
  1049.     if (prevPtr == NULL) {
  1050.     varPtr->tracePtr = tracePtr->nextPtr;
  1051.     } else {
  1052.     prevPtr->nextPtr = tracePtr->nextPtr;
  1053.     }
  1054.     ckfree((char *) tracePtr);
  1055.  
  1056.     /*
  1057.      * If this is the last trace on the variable, and the variable is
  1058.      * unset and unused, then free up the variable.
  1059.      */
  1060.  
  1061.     if (varPtr->flags & VAR_UNDEFINED) {
  1062.     CleanupVar(varPtr, (Var *) NULL);
  1063.     }
  1064. }
  1065.  
  1066. /*
  1067.  *----------------------------------------------------------------------
  1068.  *
  1069.  * Tcl_VarTraceInfo --
  1070.  *
  1071.  *    Return the clientData value associated with a trace on a
  1072.  *    variable.  This procedure can also be used to step through
  1073.  *    all of the traces on a particular variable that have the
  1074.  *    same trace procedure.
  1075.  *
  1076.  * Results:
  1077.  *    The return value is the clientData value associated with
  1078.  *    a trace on the given variable.  Information will only be
  1079.  *    returned for a trace with proc as trace procedure.  If
  1080.  *    the clientData argument is NULL then the first such trace is
  1081.  *    returned;  otherwise, the next relevant one after the one
  1082.  *    given by clientData will be returned.  If the variable
  1083.  *    doesn't exist, or if there are no (more) traces for it,
  1084.  *    then NULL is returned.
  1085.  *
  1086.  * Side effects:
  1087.  *    None.
  1088.  *
  1089.  *----------------------------------------------------------------------
  1090.  */
  1091.  
  1092. ClientData
  1093. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1094.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1095.     char *varName;        /* Name of variable;  may end with "(index)"
  1096.                  * to signify an array reference. */
  1097.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1098.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1099.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1100.                  * by this procedure, so this call will
  1101.                  * return the next trace after that one.
  1102.                  * If NULL, this call will return the
  1103.                  * first trace. */
  1104. {
  1105.     register char *p;
  1106.  
  1107.     /*
  1108.      * If varName refers to an array (it ends with a parenthesized
  1109.      * element name), then handle it specially.
  1110.      */
  1111.  
  1112.     for (p = varName; *p != '\0'; p++) {
  1113.     if (*p == '(') {
  1114.         ClientData result;
  1115.         char *open = p;
  1116.  
  1117.         do {
  1118.         p++;
  1119.         } while (*p != '\0');
  1120.         p--;
  1121.         if (*p != ')') {
  1122.         goto scalar;
  1123.         }
  1124.         *open = '\0';
  1125.         *p = '\0';
  1126.         result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
  1127.         prevClientData);
  1128.         *open = '(';
  1129.         *p = ')';
  1130.         return result;
  1131.     }
  1132.     }
  1133.  
  1134.     scalar:
  1135.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
  1136.         prevClientData);
  1137. }
  1138.  
  1139. /*
  1140.  *----------------------------------------------------------------------
  1141.  *
  1142.  * Tcl_VarTraceInfo2 --
  1143.  *
  1144.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1145.  *    instead of one.
  1146.  *
  1147.  * Results:
  1148.  *    Same as Tcl_VarTraceInfo.
  1149.  *
  1150.  * Side effects:
  1151.  *    None.
  1152.  *
  1153.  *----------------------------------------------------------------------
  1154.  */
  1155.  
  1156. ClientData
  1157. Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
  1158.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1159.     char *part1;        /* Name of variable or array. */
  1160.     char *part2;        /* Name of element within array;  NULL means
  1161.                  * trace applies to scalar variable or array
  1162.                  * as-a-whole. */
  1163.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1164.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1165.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1166.                  * by this procedure, so this call will
  1167.                  * return the next trace after that one.
  1168.                  * If NULL, this call will return the
  1169.                  * first trace. */
  1170. {
  1171.     register VarTrace *tracePtr;
  1172.     Var *varPtr, *arrayPtr;
  1173.  
  1174.     varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY,
  1175.         (char *) NULL, 0, &arrayPtr);
  1176.     if (varPtr == NULL) {
  1177.     return NULL;
  1178.     }
  1179.  
  1180.     /*
  1181.      * Find the relevant trace, if any, and return its clientData.
  1182.      */
  1183.  
  1184.     tracePtr = varPtr->tracePtr;
  1185.     if (prevClientData != NULL) {
  1186.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1187.         if ((tracePtr->clientData == prevClientData)
  1188.             && (tracePtr->traceProc == proc)) {
  1189.         tracePtr = tracePtr->nextPtr;
  1190.         break;
  1191.         }
  1192.     }
  1193.     }
  1194.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1195.     if (tracePtr->traceProc == proc) {
  1196.         return tracePtr->clientData;
  1197.     }
  1198.     }
  1199.     return NULL;
  1200. }
  1201.  
  1202. /*
  1203.  *----------------------------------------------------------------------
  1204.  *
  1205.  * Tcl_SetCmd --
  1206.  *
  1207.  *    This procedure is invoked to process the "set" Tcl command.
  1208.  *    See the user documentation for details on what it does.
  1209.  *
  1210.  * Results:
  1211.  *    A standard Tcl result value.
  1212.  *
  1213.  * Side effects:
  1214.  *    A variable's value may be changed.
  1215.  *
  1216.  *----------------------------------------------------------------------
  1217.  */
  1218.  
  1219.     /* ARGSUSED */
  1220. int
  1221. Tcl_SetCmd(dummy, interp, argc, argv)
  1222.     ClientData dummy;            /* Not used. */
  1223.     register Tcl_Interp *interp;    /* Current interpreter. */
  1224.     int argc;                /* Number of arguments. */
  1225.     char **argv;            /* Argument strings. */
  1226. {
  1227.     if (argc == 2) {
  1228.     char *value;
  1229.  
  1230.     value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1231.     if (value == NULL) {
  1232.         return TCL_ERROR;
  1233.     }
  1234.     interp->result = value;
  1235.     return TCL_OK;
  1236.     } else if (argc == 3) {
  1237.     char *result;
  1238.  
  1239.     result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
  1240.     if (result == NULL) {
  1241.         return TCL_ERROR;
  1242.     }
  1243.     interp->result = result;
  1244.     return TCL_OK;
  1245.     } else {
  1246.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1247.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1248.     return TCL_ERROR;
  1249.     }
  1250. }
  1251.  
  1252. /*
  1253.  *----------------------------------------------------------------------
  1254.  *
  1255.  * Tcl_UnsetCmd --
  1256.  *
  1257.  *    This procedure is invoked to process the "unset" Tcl command.
  1258.  *    See the user documentation for details on what it does.
  1259.  *
  1260.  * Results:
  1261.  *    A standard Tcl result value.
  1262.  *
  1263.  * Side effects:
  1264.  *    See the user documentation.
  1265.  *
  1266.  *----------------------------------------------------------------------
  1267.  */
  1268.  
  1269.     /* ARGSUSED */
  1270. int
  1271. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1272.     ClientData dummy;            /* Not used. */
  1273.     register Tcl_Interp *interp;    /* Current interpreter. */
  1274.     int argc;                /* Number of arguments. */
  1275.     char **argv;            /* Argument strings. */
  1276. {
  1277.     int i;
  1278.  
  1279.     if (argc < 2) {
  1280.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1281.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1282.     return TCL_ERROR;
  1283.     }
  1284.     for (i = 1; i < argc; i++) {
  1285.     if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != TCL_OK) {
  1286.         return TCL_ERROR;
  1287.     }
  1288.     }
  1289.     return TCL_OK;
  1290. }
  1291.  
  1292. /*
  1293.  *----------------------------------------------------------------------
  1294.  *
  1295.  * Tcl_AppendCmd --
  1296.  *
  1297.  *    This procedure is invoked to process the "append" Tcl command.
  1298.  *    See the user documentation for details on what it does.
  1299.  *
  1300.  * Results:
  1301.  *    A standard Tcl result value.
  1302.  *
  1303.  * Side effects:
  1304.  *    A variable's value may be changed.
  1305.  *
  1306.  *----------------------------------------------------------------------
  1307.  */
  1308.  
  1309.     /* ARGSUSED */
  1310. int
  1311. Tcl_AppendCmd(dummy, interp, argc, argv)
  1312.     ClientData dummy;            /* Not used. */
  1313.     register Tcl_Interp *interp;    /* Current interpreter. */
  1314.     int argc;                /* Number of arguments. */
  1315.     char **argv;            /* Argument strings. */
  1316. {
  1317.     int i;
  1318.     char *result = NULL;        /* (Initialization only needed to keep
  1319.                      * the compiler from complaining) */
  1320.  
  1321.     if (argc < 3) {
  1322.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1323.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1324.     return TCL_ERROR;
  1325.     }
  1326.  
  1327.     for (i = 2; i < argc; i++) {
  1328.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1329.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
  1330.     if (result == NULL) {
  1331.         return TCL_ERROR;
  1332.     }
  1333.     }
  1334.     interp->result = result;
  1335.     return TCL_OK;
  1336. }
  1337.  
  1338. /*
  1339.  *----------------------------------------------------------------------
  1340.  *
  1341.  * Tcl_LappendCmd --
  1342.  *
  1343.  *    This procedure is invoked to process the "lappend" Tcl command.
  1344.  *    See the user documentation for details on what it does.
  1345.  *
  1346.  * Results:
  1347.  *    A standard Tcl result value.
  1348.  *
  1349.  * Side effects:
  1350.  *    A variable's value may be changed.
  1351.  *
  1352.  *----------------------------------------------------------------------
  1353.  */
  1354.  
  1355.     /* ARGSUSED */
  1356. int
  1357. Tcl_LappendCmd(dummy, interp, argc, argv)
  1358.     ClientData dummy;            /* Not used. */
  1359.     register Tcl_Interp *interp;    /* Current interpreter. */
  1360.     int argc;                /* Number of arguments. */
  1361.     char **argv;            /* Argument strings. */
  1362. {
  1363.     int i;
  1364.     char *result = NULL;        /* (Initialization only needed to keep
  1365.                      * the compiler from complaining) */
  1366.  
  1367.     if (argc < 3) {
  1368.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1369.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1370.     return TCL_ERROR;
  1371.     }
  1372.  
  1373.     for (i = 2; i < argc; i++) {
  1374.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1375.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
  1376.     if (result == NULL) {
  1377.         return TCL_ERROR;
  1378.     }
  1379.     }
  1380.     interp->result = result;
  1381.     return TCL_OK;
  1382. }
  1383.  
  1384. /*
  1385.  *----------------------------------------------------------------------
  1386.  *
  1387.  * Tcl_ArrayCmd --
  1388.  *
  1389.  *    This procedure is invoked to process the "array" Tcl command.
  1390.  *    See the user documentation for details on what it does.
  1391.  *
  1392.  * Results:
  1393.  *    A standard Tcl result value.
  1394.  *
  1395.  * Side effects:
  1396.  *    See the user documentation.
  1397.  *
  1398.  *----------------------------------------------------------------------
  1399.  */
  1400.  
  1401.     /* ARGSUSED */
  1402. int
  1403. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1404.     ClientData dummy;            /* Not used. */
  1405.     register Tcl_Interp *interp;    /* Current interpreter. */
  1406.     int argc;                /* Number of arguments. */
  1407.     char **argv;            /* Argument strings. */
  1408. {
  1409.     int length;
  1410.     char c;
  1411.     Var *varPtr;
  1412.     Tcl_HashEntry *hPtr;
  1413.     Interp *iPtr = (Interp *) interp;
  1414.  
  1415.     if (argc < 3) {
  1416.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1417.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1418.     return TCL_ERROR;
  1419.     }
  1420.  
  1421.     /*
  1422.      * Locate the array variable (and it better be an array).
  1423.      */
  1424.  
  1425.     if (iPtr->varFramePtr == NULL) {
  1426.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1427.     } else {
  1428.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1429.     }
  1430.     if (hPtr == NULL) {
  1431.     notArray:
  1432.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1433.         (char *) NULL);
  1434.     return TCL_ERROR;
  1435.     }
  1436.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1437.     if (varPtr->flags & VAR_UPVAR) {
  1438.     varPtr = varPtr->value.upvarPtr;
  1439.     }
  1440.     if (!(varPtr->flags & VAR_ARRAY)) {
  1441.     goto notArray;
  1442.     }
  1443.  
  1444.     /*
  1445.      * Dispatch based on the option.
  1446.      */
  1447.  
  1448.     c = argv[1][0];
  1449.     length = strlen(argv[1]);
  1450.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1451.     ArraySearch *searchPtr;
  1452.  
  1453.     if (argc != 4) {
  1454.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1455.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1456.         return TCL_ERROR;
  1457.     }
  1458.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1459.     if (searchPtr == NULL) {
  1460.         return TCL_ERROR;
  1461.     }
  1462.     while (1) {
  1463.         Var *varPtr2;
  1464.  
  1465.         if (searchPtr->nextEntry != NULL) {
  1466.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1467.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1468.             break;
  1469.         }
  1470.         }
  1471.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1472.         if (searchPtr->nextEntry == NULL) {
  1473.         interp->result = "0";
  1474.         return TCL_OK;
  1475.         }
  1476.     }
  1477.     interp->result = "1";
  1478.     return TCL_OK;
  1479.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1480.     ArraySearch *searchPtr, *prevPtr;
  1481.  
  1482.     if (argc != 4) {
  1483.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1484.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1485.         return TCL_ERROR;
  1486.     }
  1487.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1488.     if (searchPtr == NULL) {
  1489.         return TCL_ERROR;
  1490.     }
  1491.     if (varPtr->searchPtr == searchPtr) {
  1492.         varPtr->searchPtr = searchPtr->nextPtr;
  1493.     } else {
  1494.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1495.         if (prevPtr->nextPtr == searchPtr) {
  1496.             prevPtr->nextPtr = searchPtr->nextPtr;
  1497.             break;
  1498.         }
  1499.         }
  1500.     }
  1501.     ckfree((char *) searchPtr);
  1502.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1503.         && (length >= 2)) {
  1504.     Tcl_HashSearch search;
  1505.     Var *varPtr2;
  1506.  
  1507.     if (argc != 3) {
  1508.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1509.             argv[0], " names arrayName\"", (char *) NULL);
  1510.         return TCL_ERROR;
  1511.     }
  1512.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1513.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1514.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1515.         if (varPtr2->flags & VAR_UNDEFINED) {
  1516.         continue;
  1517.         }
  1518.         Tcl_AppendElement(interp,
  1519.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr));
  1520.     }
  1521.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1522.         && (length >= 2)) {
  1523.     ArraySearch *searchPtr;
  1524.     Tcl_HashEntry *hPtr;
  1525.  
  1526.     if (argc != 4) {
  1527.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1528.             argv[0], " nextelement arrayName searchId\"",
  1529.             (char *) NULL);
  1530.         return TCL_ERROR;
  1531.     }
  1532.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1533.     if (searchPtr == NULL) {
  1534.         return TCL_ERROR;
  1535.     }
  1536.     while (1) {
  1537.         Var *varPtr2;
  1538.  
  1539.         hPtr = searchPtr->nextEntry;
  1540.         if (hPtr == NULL) {
  1541.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1542.         if (hPtr == NULL) {
  1543.             return TCL_OK;
  1544.         }
  1545.         } else {
  1546.         searchPtr->nextEntry = NULL;
  1547.         }
  1548.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1549.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1550.         break;
  1551.         }
  1552.     }
  1553.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1554.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1555.         && (length >= 2)) {
  1556.     Tcl_HashSearch search;
  1557.     Var *varPtr2;
  1558.     int size;
  1559.  
  1560.     if (argc != 3) {
  1561.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1562.             argv[0], " size arrayName\"", (char *) NULL);
  1563.         return TCL_ERROR;
  1564.     }
  1565.     size = 0;
  1566.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1567.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1568.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1569.         if (varPtr2->flags & VAR_UNDEFINED) {
  1570.         continue;
  1571.         }
  1572.         size++;
  1573.     }
  1574.     sprintf(interp->result, "%d", size);
  1575.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1576.         && (length >= 2)) {
  1577.     ArraySearch *searchPtr;
  1578.  
  1579.     if (argc != 3) {
  1580.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1581.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1582.         return TCL_ERROR;
  1583.     }
  1584.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1585.     if (varPtr->searchPtr == NULL) {
  1586.         searchPtr->id = 1;
  1587.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1588.     } else {
  1589.         char string[20];
  1590.  
  1591.         searchPtr->id = varPtr->searchPtr->id + 1;
  1592.         sprintf(string, "%d", searchPtr->id);
  1593.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1594.             (char *) NULL);
  1595.     }
  1596.     searchPtr->varPtr = varPtr;
  1597.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1598.         &searchPtr->search);
  1599.     searchPtr->nextPtr = varPtr->searchPtr;
  1600.     varPtr->searchPtr = searchPtr;
  1601.     } else {
  1602.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1603.         "\": should be anymore, donesearch, names, nextelement, ",
  1604.         "size, or startsearch", (char *) NULL);
  1605.     return TCL_ERROR;
  1606.     }
  1607.     return TCL_OK;
  1608. }
  1609.  
  1610. /*
  1611.  *----------------------------------------------------------------------
  1612.  *
  1613.  * MakeUpvar --
  1614.  *
  1615.  *    This procedure does all of the work of the "global" and "upvar"
  1616.  *    commands.
  1617.  *
  1618.  * Results:
  1619.  *    A standard Tcl completion code.  If an error occurs then an
  1620.  *    error message is left in iPtr->result.
  1621.  *
  1622.  * Side effects:
  1623.  *    The variable given by myName is linked to the variable in
  1624.  *    framePtr given by otherP1 and otherP2, so that references to
  1625.  *    myName are redirected to the other variable like a symbolic
  1626. *    link.
  1627.  *
  1628.  *----------------------------------------------------------------------
  1629.  */
  1630.  
  1631. static int
  1632. MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName)
  1633.     Interp *iPtr;        /* Interpreter containing variables.  Used
  1634.                  * for error messages, too. */
  1635.     CallFrame *framePtr;    /* Call frame containing "other" variable.
  1636.                  * NULL means use global context. */
  1637.     char *otherP1, *otherP2;    /* Two-part name of variable in framePtr. */
  1638.     char *myName;        /* Name of variable in local table, which
  1639.                  * will refer to otherP1/P2.  Must be a
  1640.                  * scalar. */
  1641. {
  1642.     Tcl_HashEntry *hPtr;
  1643.     Var *otherPtr, *varPtr, *arrayPtr;
  1644.     CallFrame *savedFramePtr;
  1645.     int new;
  1646.  
  1647.     /*
  1648.      * In order to use LookupVar to find "other", temporarily replace
  1649.      * the current frame pointer in the interpreter.
  1650.      */
  1651.  
  1652.     savedFramePtr = iPtr->varFramePtr;
  1653.     iPtr->varFramePtr = framePtr;
  1654.     otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
  1655.         TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr);
  1656.     iPtr->varFramePtr = savedFramePtr;
  1657.     if (otherPtr == NULL) {
  1658.     return TCL_ERROR;
  1659.     }
  1660.     if (iPtr->varFramePtr != NULL) {
  1661.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new);
  1662.     } else {
  1663.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new);
  1664.     }
  1665.     if (new) {
  1666.     varPtr = NewVar();
  1667.     Tcl_SetHashValue(hPtr, varPtr);
  1668.     varPtr->hPtr = hPtr;
  1669.     } else {
  1670.     /*
  1671.      * The variable already exists.  If it's not an upvar then it's
  1672.      * an error.  If it is an upvar, then just disconnect it from the
  1673.      * thing it currently refers to.
  1674.      */
  1675.  
  1676.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1677.     if (varPtr->flags & VAR_UPVAR) {
  1678.         Var *upvarPtr;
  1679.  
  1680.         upvarPtr = varPtr->value.upvarPtr;
  1681.         if (upvarPtr == otherPtr) {
  1682.         return TCL_OK;
  1683.         }
  1684.         upvarPtr->refCount--;
  1685.         if (upvarPtr->flags & VAR_UNDEFINED) {
  1686.         CleanupVar(upvarPtr, (Var *) NULL);
  1687.         }
  1688.     } else if (!(varPtr->flags & VAR_UNDEFINED)) {
  1689.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
  1690.         "\" already exists", (char *) NULL);
  1691.         return TCL_ERROR;
  1692.     }
  1693.     }
  1694.     varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR;
  1695.     varPtr->value.upvarPtr = otherPtr;
  1696.     otherPtr->refCount++;
  1697.     return TCL_OK;
  1698. }
  1699.  
  1700. /*
  1701.  *----------------------------------------------------------------------
  1702.  *
  1703.  * Tcl_GlobalCmd --
  1704.  *
  1705.  *    This procedure is invoked to process the "global" Tcl command.
  1706.  *    See the user documentation for details on what it does.
  1707.  *
  1708.  * Results:
  1709.  *    A standard Tcl result value.
  1710.  *
  1711.  * Side effects:
  1712.  *    See the user documentation.
  1713.  *
  1714.  *----------------------------------------------------------------------
  1715.  */
  1716.  
  1717.     /* ARGSUSED */
  1718. int
  1719. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1720.     ClientData dummy;            /* Not used. */
  1721.     Tcl_Interp *interp;            /* Current interpreter. */
  1722.     int argc;                /* Number of arguments. */
  1723.     char **argv;            /* Argument strings. */
  1724. {
  1725.     register Interp *iPtr = (Interp *) interp;
  1726.  
  1727.     if (argc < 2) {
  1728.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1729.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1730.     return TCL_ERROR;
  1731.     }
  1732.     if (iPtr->varFramePtr == NULL) {
  1733.     return TCL_OK;
  1734.     }
  1735.  
  1736.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1737.     if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv)
  1738.         != TCL_OK) {
  1739.         return TCL_ERROR;
  1740.     }
  1741.     }
  1742.     return TCL_OK;
  1743. }
  1744.  
  1745. /*
  1746.  *----------------------------------------------------------------------
  1747.  *
  1748.  * Tcl_UpvarCmd --
  1749.  *
  1750.  *    This procedure is invoked to process the "upvar" Tcl command.
  1751.  *    See the user documentation for details on what it does.
  1752.  *
  1753.  * Results:
  1754.  *    A standard Tcl result value.
  1755.  *
  1756.  * Side effects:
  1757.  *    See the user documentation.
  1758.  *
  1759.  *----------------------------------------------------------------------
  1760.  */
  1761.  
  1762.     /* ARGSUSED */
  1763. int
  1764. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1765.     ClientData dummy;            /* Not used. */
  1766.     Tcl_Interp *interp;            /* Current interpreter. */
  1767.     int argc;                /* Number of arguments. */
  1768.     char **argv;            /* Argument strings. */
  1769. {
  1770.     register Interp *iPtr = (Interp *) interp;
  1771.     int result;
  1772.     CallFrame *framePtr;
  1773.     register char *p;
  1774.  
  1775.     if (argc < 3) {
  1776.     upvarSyntax:
  1777.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1778.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1779.         (char *) NULL);
  1780.     return TCL_ERROR;
  1781.     }
  1782.  
  1783.     /*
  1784.      * Find the hash table containing the variable being referenced.
  1785.      */
  1786.  
  1787.     result = TclGetFrame(interp, argv[1], &framePtr);
  1788.     if (result == -1) {
  1789.     return TCL_ERROR;
  1790.     }
  1791.     argc -= result+1;
  1792.     if ((argc & 1) != 0) {
  1793.     goto upvarSyntax;
  1794.     }
  1795.     argv += result+1;
  1796.  
  1797.     /*
  1798.      * Iterate over all the pairs of (other variable, local variable)
  1799.      * names.  For each pair, divide the other variable name into two
  1800.      * parts, then call MakeUpvar to do all the work of creating linking
  1801.      * it to the local variable.
  1802.      */
  1803.  
  1804.     for ( ; argc > 0; argc -= 2, argv += 2) {
  1805.     for (p = argv[0]; *p != 0; p++) {
  1806.         if (*p == '(') {
  1807.         char *open = p;
  1808.  
  1809.         do {
  1810.             p++;
  1811.         } while (*p != '\0');
  1812.         p--;
  1813.         if (*p != ')') {
  1814.             goto scalar;
  1815.         }
  1816.         *open = '\0';
  1817.         *p = '\0';
  1818.         result = MakeUpvar(iPtr, framePtr, argv[0], open+1, argv[1]);
  1819.         *open = '(';
  1820.         *p = ')';
  1821.         goto checkResult;
  1822.         }
  1823.     }
  1824.     scalar:
  1825.     result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1]);
  1826.  
  1827.     checkResult:
  1828.     if (result != TCL_OK) {
  1829.         return TCL_ERROR;
  1830.     }
  1831.     }
  1832.     return TCL_OK;
  1833. }
  1834.  
  1835. /*
  1836.  *----------------------------------------------------------------------
  1837.  *
  1838.  * CallTraces --
  1839.  *
  1840.  *    This procedure is invoked to find and invoke relevant
  1841.  *    trace procedures associated with a particular operation on
  1842.  *    a variable.  This procedure invokes traces both on the
  1843.  *    variable and on its containing array (where relevant).
  1844.  *
  1845.  * Results:
  1846.  *    The return value is NULL if no trace procedures were invoked, or
  1847.  *    if all the invoked trace procedures returned successfully.
  1848.  *    The return value is non-zero if a trace procedure returned an
  1849.  *    error (in this case no more trace procedures were invoked after
  1850.  *    the error was returned).  In this case the return value is a
  1851.  *    pointer to a static string describing the error.
  1852.  *
  1853.  * Side effects:
  1854.  *    Almost anything can happen, depending on trace;  this procedure
  1855.  *    itself doesn't have any side effects.
  1856.  *
  1857.  *----------------------------------------------------------------------
  1858.  */
  1859.  
  1860. static char *
  1861. CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
  1862.     Interp *iPtr;            /* Interpreter containing variable. */
  1863.     register Var *arrayPtr;        /* Pointer to array variable that
  1864.                      * contains the variable, or NULL if
  1865.                      * the variable isn't an element of an
  1866.                      * array. */
  1867.     Var *varPtr;            /* Variable whose traces are to be
  1868.                      * invoked. */
  1869.     char *part1, *part2;        /* Variable's two-part name. */
  1870.     int flags;                /* Flags to pass to trace procedures:
  1871.                      * indicates what's happening to
  1872.                      * variable, plus other stuff like
  1873.                      * TCL_GLOBAL_ONLY and
  1874.                      * TCL_INTERP_DESTROYED. */
  1875. {
  1876.     register VarTrace *tracePtr;
  1877.     ActiveVarTrace active;
  1878.     char *result;
  1879.  
  1880.     /*
  1881.      * If there are already similar trace procedures active for the
  1882.      * variable, don't call them again.
  1883.      */
  1884.  
  1885.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  1886.     return NULL;
  1887.     }
  1888.     varPtr->flags |= VAR_TRACE_ACTIVE;
  1889.     varPtr->refCount++;
  1890.  
  1891.     /*
  1892.      * Invoke traces on the array containing the variable, if relevant.
  1893.      */
  1894.  
  1895.     result = NULL;
  1896.     active.nextPtr = iPtr->activeTracePtr;
  1897.     iPtr->activeTracePtr = &active;
  1898.     if (arrayPtr != NULL) {
  1899.     arrayPtr->refCount++;
  1900.     active.varPtr = arrayPtr;
  1901.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  1902.         tracePtr = active.nextTracePtr) {
  1903.         active.nextTracePtr = tracePtr->nextPtr;
  1904.         if (!(tracePtr->flags & flags)) {
  1905.         continue;
  1906.         }
  1907.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  1908.             (Tcl_Interp *) iPtr, part1, part2, flags);
  1909.         if (result != NULL) {
  1910.         if (flags & TCL_TRACE_UNSETS) {
  1911.             result = NULL;
  1912.         } else {
  1913.             goto done;
  1914.         }
  1915.         }
  1916.     }
  1917.     }
  1918.  
  1919.     /*
  1920.      * Invoke traces on the variable itself.
  1921.      */
  1922.  
  1923.     if (flags & TCL_TRACE_UNSETS) {
  1924.     flags |= TCL_TRACE_DESTROYED;
  1925.     }
  1926.     active.varPtr = varPtr;
  1927.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  1928.         tracePtr = active.nextTracePtr) {
  1929.     active.nextTracePtr = tracePtr->nextPtr;
  1930.     if (!(tracePtr->flags & flags)) {
  1931.         continue;
  1932.     }
  1933.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  1934.         (Tcl_Interp *) iPtr, part1, part2, flags);
  1935.     if (result != NULL) {
  1936.         if (flags & TCL_TRACE_UNSETS) {
  1937.         result = NULL;
  1938.         } else {
  1939.         goto done;
  1940.         }
  1941.     }
  1942.     }
  1943.  
  1944.     /*
  1945.      * Restore the variable's flags, remove the record of our active
  1946.      * traces, and then return.
  1947.      */
  1948.  
  1949.     done:
  1950.     if (arrayPtr != NULL) {
  1951.     arrayPtr->refCount--;
  1952.     }
  1953.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  1954.     varPtr->refCount--;
  1955.     iPtr->activeTracePtr = active.nextPtr;
  1956.     return result;
  1957. }
  1958.  
  1959. /*
  1960.  *----------------------------------------------------------------------
  1961.  *
  1962.  * NewVar --
  1963.  *
  1964.  *    Create a new variable with a given amount of storage
  1965.  *    space.
  1966.  *
  1967.  * Results:
  1968.  *    The return value is a pointer to the new variable structure.
  1969.  *    The variable will not be part of any hash table yet.  Its
  1970.  *    initial value is empty.
  1971.  *
  1972.  * Side effects:
  1973.  *    Storage gets allocated.
  1974.  *
  1975.  *----------------------------------------------------------------------
  1976.  */
  1977.  
  1978. static Var *
  1979. NewVar()
  1980. {
  1981.     register Var *varPtr;
  1982.  
  1983.     varPtr = (Var *) ckalloc(sizeof(Var));
  1984.     varPtr->valueLength = 0;
  1985.     varPtr->valueSpace = 0;
  1986.     varPtr->value.string = NULL;
  1987.     varPtr->hPtr = NULL;
  1988.     varPtr->refCount = 0;
  1989.     varPtr->tracePtr = NULL;
  1990.     varPtr->searchPtr = NULL;
  1991.     varPtr->flags = VAR_UNDEFINED;
  1992.     return varPtr;
  1993. }
  1994.  
  1995. /*
  1996.  *----------------------------------------------------------------------
  1997.  *
  1998.  * ParseSearchId --
  1999.  *
  2000.  *    This procedure translates from a string to a pointer to an
  2001.  *    active array search (if there is one that matches the string).
  2002.  *
  2003.  * Results:
  2004.  *    The return value is a pointer to the array search indicated
  2005.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2006.  *    interp->result contains an error message.
  2007.  *
  2008.  * Side effects:
  2009.  *    None.
  2010.  *
  2011.  *----------------------------------------------------------------------
  2012.  */
  2013.  
  2014. static ArraySearch *
  2015. ParseSearchId(interp, varPtr, varName, string)
  2016.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2017.     Var *varPtr;        /* Array variable search is for. */
  2018.     char *varName;        /* Name of array variable that search is
  2019.                  * supposed to be for. */
  2020.     char *string;        /* String containing id of search.  Must have
  2021.                  * form "search-num-var" where "num" is a
  2022.                  * decimal number and "var" is a variable
  2023.                  * name. */
  2024. {
  2025.     char *end;
  2026.     int id;
  2027.     ArraySearch *searchPtr;
  2028.  
  2029.     /*
  2030.      * Parse the id into the three parts separated by dashes.
  2031.      */
  2032.  
  2033.     if ((string[0] != 's') || (string[1] != '-')) {
  2034.     syntax:
  2035.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2036.         "\"", (char *) NULL);
  2037.     return NULL;
  2038.     }
  2039.     id = strtoul(string+2, &end, 10);
  2040.     if ((end == (string+2)) || (*end != '-')) {
  2041.     goto syntax;
  2042.     }
  2043.     if (strcmp(end+1, varName) != 0) {
  2044.     Tcl_AppendResult(interp, "search identifier \"", string,
  2045.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2046.     return NULL;
  2047.     }
  2048.  
  2049.     /*
  2050.      * Search through the list of active searches on the interpreter
  2051.      * to see if the desired one exists.
  2052.      */
  2053.  
  2054.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2055.         searchPtr = searchPtr->nextPtr) {
  2056.     if (searchPtr->id == id) {
  2057.         return searchPtr;
  2058.     }
  2059.     }
  2060.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2061.         (char *) NULL);
  2062.     return NULL;
  2063. }
  2064.  
  2065. /*
  2066.  *----------------------------------------------------------------------
  2067.  *
  2068.  * DeleteSearches --
  2069.  *
  2070.  *    This procedure is called to free up all of the searches
  2071.  *    associated with an array variable.
  2072.  *
  2073.  * Results:
  2074.  *    None.
  2075.  *
  2076.  * Side effects:
  2077.  *    Memory is released to the storage allocator.
  2078.  *
  2079.  *----------------------------------------------------------------------
  2080.  */
  2081.  
  2082. static void
  2083. DeleteSearches(arrayVarPtr)
  2084.     register Var *arrayVarPtr;        /* Variable whose searches are
  2085.                      * to be deleted. */
  2086. {
  2087.     ArraySearch *searchPtr;
  2088.  
  2089.     while (arrayVarPtr->searchPtr != NULL) {
  2090.     searchPtr = arrayVarPtr->searchPtr;
  2091.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2092.     ckfree((char *) searchPtr);
  2093.     }
  2094. }
  2095.  
  2096. /*
  2097.  *----------------------------------------------------------------------
  2098.  *
  2099.  * TclDeleteVars --
  2100.  *
  2101.  *    This procedure is called to recycle all the storage space
  2102.  *    associated with a table of variables.  For this procedure
  2103.  *    to work correctly, it must not be possible for any of the
  2104.  *    variable in the table to be accessed from Tcl commands
  2105.  *    (e.g. from trace procedures).
  2106.  *
  2107.  * Results:
  2108.  *    None.
  2109.  *
  2110.  * Side effects:
  2111.  *    Variables are deleted and trace procedures are invoked, if
  2112.  *    any are declared.
  2113.  *
  2114.  *----------------------------------------------------------------------
  2115.  */
  2116.  
  2117. void
  2118. TclDeleteVars(iPtr, tablePtr)
  2119.     Interp *iPtr;        /* Interpreter to which variables belong. */
  2120.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  2121.                  * delete. */
  2122. {
  2123.     Tcl_HashSearch search;
  2124.     Tcl_HashEntry *hPtr;
  2125.     register Var *varPtr;
  2126.     Var *upvarPtr;
  2127.     int flags;
  2128.     ActiveVarTrace *activePtr;
  2129.  
  2130.     flags = TCL_TRACE_UNSETS;
  2131.     if (tablePtr == &iPtr->globalTable) {
  2132.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  2133.     }
  2134.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  2135.         hPtr = Tcl_NextHashEntry(&search)) {
  2136.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2137.  
  2138.     /*
  2139.      * For global/upvar variables referenced in procedures, decrement
  2140.      * the reference count on the variable referred to, and free up
  2141.      * the referenced variable if it's no longer needed.
  2142.      */
  2143.  
  2144.     if (varPtr->flags & VAR_UPVAR) {
  2145.         upvarPtr = varPtr->value.upvarPtr;
  2146.         upvarPtr->refCount--;
  2147.         if (upvarPtr->flags & VAR_UNDEFINED) {
  2148.         CleanupVar(upvarPtr, (Var *) NULL);
  2149.         }
  2150.     }
  2151.  
  2152.     /*
  2153.      * Invoke traces on the variable that is being deleted, then
  2154.      * free up the variable's space (no need to free the hash entry
  2155.      * here, unless we're dealing with a global variable:  the
  2156.      * hash entries will be deleted automatically when the whole
  2157.      * table is deleted).
  2158.      */
  2159.  
  2160.     if (varPtr->tracePtr != NULL) {
  2161.         (void) CallTraces(iPtr, (Var *) NULL, varPtr,
  2162.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags);
  2163.         while (varPtr->tracePtr != NULL) {
  2164.         VarTrace *tracePtr = varPtr->tracePtr;
  2165.         varPtr->tracePtr = tracePtr->nextPtr;
  2166.         ckfree((char *) tracePtr);
  2167.         }
  2168.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2169.             activePtr = activePtr->nextPtr) {
  2170.         if (activePtr->varPtr == varPtr) {
  2171.             activePtr->nextTracePtr = NULL;
  2172.         }
  2173.         }
  2174.     }
  2175.     if (varPtr->flags & VAR_ARRAY) {
  2176.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags);
  2177.     }
  2178.     if (varPtr->valueSpace > 0) {
  2179.         /*
  2180.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2181.          * currently points to this variable (for example, a "set" or
  2182.          * "lappend" command was the last command in a procedure that's
  2183.          * being returned from).  If this is the case, then just pass
  2184.          * ownership of the value string to the Tcl interpreter.
  2185.          */
  2186.  
  2187.         if (iPtr->result == varPtr->value.string) {
  2188.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2189.         } else {
  2190.         ckfree(varPtr->value.string);
  2191.         }
  2192.         varPtr->valueSpace = 0;
  2193.     }
  2194.     varPtr->hPtr = NULL;
  2195.     varPtr->tracePtr = NULL;
  2196.     varPtr->flags = VAR_UNDEFINED;
  2197.     if (varPtr->refCount == 0) {
  2198.         ckfree((char *) varPtr);
  2199.     }
  2200.     }
  2201.     Tcl_DeleteHashTable(tablePtr);
  2202. }
  2203.  
  2204. /*
  2205.  *----------------------------------------------------------------------
  2206.  *
  2207.  * DeleteArray --
  2208.  *
  2209.  *    This procedure is called to free up everything in an array
  2210.  *    variable.  It's the caller's responsibility to make sure
  2211.  *    that the array is no longer accessible before this procedure
  2212.  *    is called.
  2213.  *
  2214.  * Results:
  2215.  *    None.
  2216.  *
  2217.  * Side effects:
  2218.  *    All storage associated with varPtr's array elements is deleted
  2219.  *    (including the hash table).  Delete trace procedures for
  2220.  *    array elements are invoked.
  2221.  *
  2222.  *----------------------------------------------------------------------
  2223.  */
  2224.  
  2225. static void
  2226. DeleteArray(iPtr, arrayName, varPtr, flags)
  2227.     Interp *iPtr;            /* Interpreter containing array. */
  2228.     char *arrayName;            /* Name of array (used for trace
  2229.                      * callbacks). */
  2230.     Var *varPtr;            /* Pointer to variable structure. */
  2231.     int flags;                /* Flags to pass to CallTraces:
  2232.                      * TCL_TRACE_UNSETS and sometimes
  2233.                      * TCL_INTERP_DESTROYED and/or
  2234.                      * TCL_GLOBAL_ONLY. */
  2235. {
  2236.     Tcl_HashSearch search;
  2237.     register Tcl_HashEntry *hPtr;
  2238.     register Var *elPtr;
  2239.     ActiveVarTrace *activePtr;
  2240.  
  2241.     DeleteSearches(varPtr);
  2242.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2243.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2244.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2245.     if (elPtr->valueSpace != 0) {
  2246.         /*
  2247.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2248.          * currently points to this element (for example, a "set" or
  2249.          * "lappend" command was the last command in a procedure that's
  2250.          * being returned from).  If this is the case, then just pass
  2251.          * ownership of the value string to the Tcl interpreter.
  2252.          */
  2253.  
  2254.         if (iPtr->result == elPtr->value.string) {
  2255.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2256.         } else {
  2257.         ckfree(elPtr->value.string);
  2258.         }
  2259.         elPtr->valueSpace = 0;
  2260.     }
  2261.     elPtr->hPtr = NULL;
  2262.     if (elPtr->tracePtr != NULL) {
  2263.         elPtr->flags &= ~VAR_TRACE_ACTIVE;
  2264.         (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName,
  2265.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2266.         while (elPtr->tracePtr != NULL) {
  2267.         VarTrace *tracePtr = elPtr->tracePtr;
  2268.         elPtr->tracePtr = tracePtr->nextPtr;
  2269.         ckfree((char *) tracePtr);
  2270.         }
  2271.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2272.             activePtr = activePtr->nextPtr) {
  2273.         if (activePtr->varPtr == elPtr) {
  2274.             activePtr->nextTracePtr = NULL;
  2275.         }
  2276.         }
  2277.     }
  2278.     elPtr->flags = VAR_UNDEFINED;
  2279.     if (elPtr->refCount == 0) {
  2280.         ckfree((char *) elPtr);
  2281.     }
  2282.     }
  2283.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2284.     ckfree((char *) varPtr->value.tablePtr);
  2285. }
  2286.  
  2287. /*
  2288.  *----------------------------------------------------------------------
  2289.  *
  2290.  * CleanupVar --
  2291.  *
  2292.  *    This procedure is called when it looks like it may be OK
  2293.  *    to free up the variable's record and hash table entry, and
  2294.  *    those of its containing parent.  It's called, for example,
  2295.  *    when a trace on a variable deletes the variable.
  2296.  *
  2297.  * Results:
  2298.  *    None.
  2299.  *
  2300.  * Side effects:
  2301.  *    If the variable (or its containing array) really is dead then
  2302.  *    its record, and possibly its hash table entry, gets freed up.
  2303.  *
  2304.  *----------------------------------------------------------------------
  2305.  */
  2306.  
  2307. static void
  2308. CleanupVar(varPtr, arrayPtr)
  2309.     Var *varPtr;        /* Pointer to variable that may be a
  2310.                  * candidate for being expunged. */
  2311.     Var *arrayPtr;        /* Array that contains the variable, or
  2312.                  * NULL if this variable isn't an array
  2313.                  * element. */
  2314. {
  2315.     if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0)
  2316.         && (varPtr->tracePtr == NULL)) {
  2317.     if (varPtr->hPtr != NULL) {
  2318.         Tcl_DeleteHashEntry(varPtr->hPtr);
  2319.     }
  2320.     ckfree((char *) varPtr);
  2321.     }
  2322.     if (arrayPtr != NULL) {
  2323.     if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0)
  2324.         && (arrayPtr->tracePtr == NULL)) {
  2325.         if (arrayPtr->hPtr != NULL) {
  2326.         Tcl_DeleteHashEntry(arrayPtr->hPtr);
  2327.         }
  2328.         ckfree((char *) arrayPtr);
  2329.     }
  2330.     }
  2331.     return;
  2332. }
  2333.  
  2334. /*
  2335.  *----------------------------------------------------------------------
  2336.  *
  2337.  * VarErrMsg --
  2338.  *
  2339.  *    Generate a reasonable error message describing why a variable
  2340.  *    operation failed.
  2341.  *
  2342.  * Results:
  2343.  *    None.
  2344.  *
  2345.  * Side effects:
  2346.  *    Interp->result is reset to hold a message identifying the
  2347.  *    variable given by part1 and part2 and describing why the
  2348.  *    variable operation failed.
  2349.  *
  2350.  *----------------------------------------------------------------------
  2351.  */
  2352.  
  2353. static void
  2354. VarErrMsg(interp, part1, part2, operation, reason)
  2355.     Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2356.     char *part1, *part2;    /* Variable's two-part name. */
  2357.     char *operation;        /* String describing operation that failed,
  2358.                  * e.g. "read", "set", or "unset". */
  2359.     char *reason;        /* String describing why operation failed. */
  2360. {
  2361.     Tcl_ResetResult(interp);
  2362.     Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL);
  2363.     if (part2 != NULL) {
  2364.     Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
  2365.     }
  2366.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2367. }
  2368.